#!/usr/bin/env ypsilon

;; glut-demo.scm:
;;   GLUT, OpenGL, FFI, and Concurrent GC Stress Test
;;
;; Requirements:
;;   Darwin:  OpenGL.framework GLUT.framework
;;   Windows: opengl32.dll glut32.dll
;;   Linux:   libGL.so.1 libglut.so.3    
               
(import (core primitives))
(auto-compile-verbose #t)
(scheme-load-verbose #t)
  
(begin
  
  (import (core) (gl) (glut) (rnrs) (rnrs programs))

  (define object glutSolidIcosahedron)
  (define reverse #t)
  (define angle 0.0)
  (define last-update 0)

  (define display
    (lambda ()
      (glClear (+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT))
      (do ((y 2.0 (+ y 3.0)))
        ((> y 14.0))
        (do ((x 2.0 (+ x 3.0)))
          ((> x 14.0))
          (if reverse
              (render-one x y
                          0.4 (/ x 40.0) (/ y 40.0)
                          (/ x 20.0) (/ y 20.0) 0.4
                          (/ x 20.0) 0.2 (/ y 20.0)
                          (/ (+ x y) 20.0 100.0))
              (render-one x y
                          (/ y 40.0) (/ x 40.0) 0.4
                          (/ x 20.0) 0.4 (/ y 20.0)
                          0.2 (/ x 20.0) (/ y 20.0)
                          (/ (+ x y) 20.0 100.0)))))
      (glutSwapBuffers)))

  (define rotate
    (lambda ()
      (cond ((< (+ last-update 16000) (microsecond))
             (if (= (glutGetWindow) 0) (exit 0))
             (if reverse
                 (let ((new-angle (+ angle 2.0)))
                   (if (>= new-angle 360.0)
                       (set! angle (- new-angle 360.0))
                       (set! angle new-angle)))
                 (let ((new-angle (- angle 2.0)))
                   (if (< new-angle 360.0)
                       (set! angle (+ new-angle 360.0))
                       (set! angle new-angle))))
             (set! last-update (microsecond))
             (glutPostRedisplay)))))

  (define mouse
    (lambda (button state x y)
      (and (= state 0) (set! reverse (not reverse)))
      (format #t "mouse callback ~s ~s ~s ~s ~%" button state x y)))

  (define menu
    (lambda (m)
      (format #t "menu callback ~s ~%" m)
      (case m
        ((1) (set! object glutSolidIcosahedron))
        ((2) (set! object glutSolidOctahedron))
        ((3) (set! object glutSolidTetrahedron))
        ((4) (exit)))))

  (define reshape
    (lambda (w h)
      (format #t "reshape callback ~s ~s ~%" w h)
      (and (> w 0)
           (> h 0)
           (begin
             (glViewport 0 0 w h)
             (glMatrixMode GL_PROJECTION)
             (glLoadIdentity)
             (if (<= w h)
                 (glOrtho 0.0 16.0 0.0 (/ (* 16.0 h) w) -10.0 10.0)
                 (glOrtho 0.0 (/ (* 16.0 w) h) 0.0 16.0 -10.0 10.0))
             (glMatrixMode GL_MODELVIEW)))))

  (define visibility
    (lambda (state)
      (format #t "visibility callback ~s ~%" state)))

  (define f32vector
    (lambda lst
      (define-syntax f32set!
        (syntax-rules ()
          ((_ bv n value)
           (bytevector-ieee-single-native-set! bv (* n 4) value))))
      (let ((bv (make-bytevector (* (length lst) 4))))
        (let loop ((i 0) (lst lst))
          (cond ((null? lst) bv)
                (else
                 (f32set! bv i (car lst))
                 (loop (+ i 1) (cdr lst))))))))

  (define render-one
    (lambda (x y ambr ambg ambb difr difg difb specr specg specb shine)
      (glPushMatrix)
      (glTranslatef x y 0.0)
      (glRotatef angle -0.3 1.0 -0.5)
      (glMaterialfv GL_FRONT GL_AMBIENT (f32vector ambr ambg ambb 1.0))
      (glMaterialfv GL_FRONT GL_DIFFUSE (f32vector difr difg difb 1.0))
      (glMaterialfv GL_FRONT GL_SPECULAR (f32vector specr specg specb 1.0))
      (glMaterialf GL_FRONT GL_SHININESS (* shine 128.0))
      (object)
      (glPopMatrix)))

#;(import (trace))
#;(trace render-one)
#;(collect-notify #t)

  (define run
    (lambda ()
      (glutInitDisplayMode (+ GLUT_DOUBLE GLUT_RGBA GLUT_DEPTH))
      (glutInitWindowPosition 100 100)
      (glutInitWindowSize 500 500)
      (glutInit (vector (length (command-line))) (apply vector (command-line)))
      (glutCreateWindow "Hello GLUT")
      (glLightfv GL_LIGHT0 GL_AMBIENT (f32vector 0.0 0.0 0.0 1.0))
      (glLightfv GL_LIGHT0 GL_DIFFUSE (f32vector 1.0 1.0 1.0 1.0))
      (glLightfv GL_LIGHT0 GL_POSITION (f32vector 0.0 3.0 3.0 0.0))
      (glLightModelfv GL_LIGHT_MODEL_AMBIENT (f32vector 0.2 0.2 0.2 1.0))
      (glLightModelfv GL_LIGHT_MODEL_LOCAL_VIEWER (f32vector 0.0))
      (glFrontFace GL_CW)
      (glEnable GL_LIGHTING)
      (glEnable GL_LIGHT0)
      (glEnable GL_AUTO_NORMAL)
      (glEnable GL_NORMALIZE)
      (glEnable GL_DEPTH_TEST)
      (glDepthFunc GL_LESS)
      (glutDisplayFunc display)
      (glutReshapeFunc reshape)
      (glutVisibilityFunc visibility)
      (glutMouseFunc mouse)
      (glutIdleFunc rotate)
      (glutCreateMenu menu)
      (glutAddMenuEntry "Icosahedron" 1)
      (glutAddMenuEntry "Octahedron" 2)
      (glutAddMenuEntry "Tetrahedron" 3)
      (glutAddMenuEntry "Exit" 4)
      (glutAttachMenu GLUT_RIGHT_BUTTON)
      (glutMainLoop)))

  (run))
